Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d4/8puzzle.arc/8PUZZLE.PAS

Pascal/Delphi Source File | 1988-12-22 | 14.0 KB | 663 lines

program puzzle8;

{
  Copyright Norman Newman, Kibbutz Mishmar David, Israel.
  This Turbo Pascal version was successfully ported
  from the PDP version on 4 July 1987.

  This is a more Turbo-like version, March 1988.
  Updated to Turbo-4, October 1988.

  Permission is granted to use this program, or portions thereof,
  for non-commercial purposes. All other rights are reserved to
  the original author.

}
uses dos, crt;

const
 version = 9;
 zero = 48; { ASCII ord('0') }
 goal = '1234 5678';
 hash_max = 1008;
 hash_max_plus = 1009;

type
 square = packed array [1..9] of char;

var
 original, onscreen: square;
 hash_table: array [0..hash_max] of square;
 table: array [1..81] of integer;
 preint: array [1..9] of integer;
 prech: array ['1'..'8'] of char;
 moves: array [1..9,1..5] of integer;
 compcount, humcount: integer;
 complay, humplay: boolean;
 ch: char;
 video_mode: byte;
 regs: registers;

{****************************************************}

 function get_mode: byte;
  { return our current video mode }
  begin
   regs.ax:= $0F00;
   intr ($10, regs);
   get_mode:= regs.al
  end;

 procedure set_mode (mode: byte);
  { set the video mode }
  begin
   regs.ah:= 0;
   regs.al:= mode;
   intr ($10, regs);
  end;

 function inkey: integer;
  { this function returns the code of the key pressed in the low
    byte.
    If the high byte is 0, an extended code was read;
    if the high byte is 1, an ordinary key was read
  }
  begin
   regs.ah:= 7; { read character without echo }
   msdos (regs);
   if regs.al > 0 { ordinary key }
    then regs.ah:= 1
    else
     begin { get rest of key code }
      msdos (regs);
      regs.ah:= 0
     end;
   inkey:= regs.ax
  end { inkey };

 function evaluate (var p:square): integer;
  var
   i, tmp: integer;
   ch: char;
   blank: boolean;

  begin
   tmp:= 0;
   i:= 0;
   while i < 9 do
    begin
     i:= i + 1;
     ch:= p[i];
     blank:= ch = ' ';
     if not blank
      then tmp:= tmp + table[(i-1)*9 + ord(ch) - zero]
      else tmp:= tmp + table[i*9];

     if blank
      then if i <> 5 then tmp:= tmp + 2
                     else
      else
       case i of
         5:;
         2,4,6,8:
          if p[5] <> ' '
           then if (p[preint[i]] <> prech[ch])
                   and (ch <> prech[p[5]])
                   then tmp:= tmp + 5
                   else
          else
           if p[preint[i]] <> prech[ch]
            then tmp:= tmp + 5;
         1,3,7,9:
          if p[preint[i]] <> prech[ch]
           then tmp:= tmp + 3
       end
    end;
   evaluate:= tmp
 end { evaluate };

{***********************************************}

 procedure print_square (var p: square);
  var
   i,j: integer;

  begin
   for i:= 1 to 3 do
    begin
     if p[i] <> onscreen[i]
      then
       begin
        gotoxy(i+i+17,10);
        write (p[i]);
        onscreen[i]:= p[i]
       end;

    j:= i + 3;
    if p[j] <> onscreen[j]
     then
      begin
       gotoxy(i+i+17,12);
       write (p[j]);
       onscreen[j]:= p[j]
      end;

    j:= j + 3;
    if p[j] <> onscreen[j]
     then
      begin
       gotoxy(i+i+17,14);
       write (p[j]);
       onscreen[j]:= p[j]
      end
    end;
   delay (25);
  end { print_square };

{***********************************************}

 procedure initialise;

  procedure init_eval;
   var
    a,b,c: packed array [1..27] of char;
    i: byte;

   begin
    a:= '012132342101223321210314322';
    b:= '123021231212112120321203211';
    c:= '234130122323221011432312102';
    for i:= 1 to 27 do
     begin
      table[i]:= ord(a[i]) - zero;
      table[i+27]:= ord(b[i]) - zero;
      table[i+54]:= ord(c[i]) - zero
     end;

   preint[1]:= 4; preint[2]:= 1; preint[3]:= 2;
   preint[4]:= 7; preint[5]:= 5; preint[6]:= 3;
   preint[7]:= 8; preint[8]:= 9; preint[9]:= 6;

   prech['1']:= '4'; prech['2']:= '1'; prech['3']:= '2';
   prech['4']:= '6'; prech['5']:= '3'; prech['6']:= '7';
   prech['7']:= '8'; prech['8']:= '5';

  end { init_eval };

  procedure initmov;
   var
    i,j: byte;
    tab: packed array [1..45] of char;

   begin
    tab:= '224003153022600315704246833590248003759026800';
    for i:= 1 to 9 do
     for j:= 1 to 5 do
      moves[i,j]:= ord(tab[(i-1)*5+j]) - zero
   end { initmov };

  procedure init_square;
   var
    i: integer;
    ch: char;

   procedure random_entry;
    var
     i,hole, new_hole: integer;

    begin
     randomize;
     original:= goal;
     hole:= 5;
     for i:= 1 to 500 do
      begin
       new_hole:= random(moves[hole,1]) + 1;
       new_hole:= moves[hole,new_hole + 1];
       original[hole]:= original[new_hole];
       original[new_hole]:= ' ';
       hole:= new_hole
      end
    end { random entry };

  procedure debug_entry;
   var
    i: byte;
    key: integer;

   begin
    gotoxy(1,14);
    for i:= 1 to 9 do
     begin
      write ('Square #':15, i:1, ' ? ');
      repeat
       key:= inkey
      until (hi(key) = 1) and (lo(key) in [32, 49..56]);
      original[i]:= chr(key);
      writeln (chr(key))
     end;
   end { debug_entry };

   begin { init_square }
    gotoxy (10,13);
    write ('<D>ebug or <R>andom ? ');
    ch:= readkey;
    if (ch = 'd') or (ch = 'D')
     then debug_entry
     else random_entry;
    gotoxy (1,13);
    clreol
   end { init_square };

  procedure init_frame;
   var
    i,j: byte;

    procedure line;
     begin
      write (chr(186), chr(186):2, chr(186):2, chr(186):2)
     end;

    procedure join;
     begin
      write (chr(204), chr(205), chr(206), chr(205),
             chr(206), chr(205), chr(185));
     end;

   begin
    fillchar (onscreen, 9, ' ');
    highvideo;
    gotoxy (18,9);
    { top line }
    write (chr(201),chr(205), chr(203), chr(205),
           chr(203), chr(205), chr(187));
    gotoxy(18,10); line;
    gotoxy(18,11); join;
    gotoxy(18,12); line;
    gotoxy(18,13); join;
    gotoxy(18,14); line;
    { bottom line }
    gotoxy(18,15);
    write (chr(200), chr(205), chr(202), chr(205), chr(202),
           chr(205), chr(188));
    normvideo;
   end { init_frame };

  begin { initialise }
   init_eval;
   initmov;
   init_square;
   init_frame;
   fillchar (hash_table, hash_max_plus*9, 'a')
  end;

{***********************************************}

 procedure human;
  var
   sq: square;
   your_move, hole, i: integer;
   flag: boolean;

  function legal : boolean;
   begin
    case hole of
     1: legal:= your_move > 0;
     2: legal:= your_move <> -3;
     3: legal:= (your_move = -1) or (your_move = 3);
     4: legal:= your_move <> -1;
     5: legal:= true;
     6: legal:= your_move <> 1;
     7: legal:= (your_move = -3) or (your_move = 1);
     8: legal:= your_move <> 3;
     9: legal:= your_move < 0;
     else legal:= true
    end
   end { legal };

  begin { human }
   sq:= original;
   gotoxy(1,19);
   writeln ('Use the arrow keys to move the hole');
   write ('F10 to quit');
   clreol;
   gotoxy(1,24);
   write('Moves so far - ');

   while sq <> goal do
    begin
     hole:= 1;
     while sq[hole] <> ' ' do hole:= hole + 1;
     repeat
      gotoxy(1,22);
      write('Which way do you want to move the hole? ');

      case inkey of
       72: your_move:= -3;
       75: your_move:= -1;
       80: your_move:= 3;
       77: your_move:= 1;
       68: your_move:= 4; { finish }
       else your_move:= 5 { illegal }
      end
    until legal;

    if your_move = 5 then { do nothing }
    else if your_move = 4
     then
      begin
       humplay:= false;
       humcount:= 0;
       sq:= goal { force an end }
      end
    else if legal
     then
      begin
       sq[hole]:= sq[hole + your_move];
       sq[hole + your_move]:= ' ';
       print_square(sq);
       humcount:= humcount + 1;
       gotoxy(16,24);
       write (humcount)
      end
   end
  end;

{***********************************************}

 procedure computer;
  label
   999;

  type
   node = ^node_type;
   node_type = record
                index: 0..hash_max;
                score, hole: integer;
                parent, next: node
               end;

  var
   head, n, son, free: node;
   i, inc: integer;
   finished: boolean;

  procedure insert (var head: node; son: node);
   var
    front, rear: node;
    count: integer;
    duplicate: boolean;

    procedure attach (head: node);
     begin
      if front = nil
       then front:= head
       else rear^.next:= head;
      rear:= head
    end { attach };

   begin { insert }
    duplicate:= false;
    if son^.score < head^.score
     then
      begin
       son^.next:= head;
       head:= son
      end
     else
      begin
       front:= nil;
       count:= 0;
       while son^.score >= head^.score do
        begin
         duplicate:= son^.index = head^.index;
         attach (head);
         head:= head^.next;
         count:= count + 1
        end;

       if not duplicate then duplicate:= count > 20;
       if duplicate
        then attach (head)
        else
         begin
          son^.next:= head;
          attach (son)
         end;
       head:= front
      end
   end { insert };

  function hash (var sq: square): integer;
  { returns -1 if sq is not a new square,
    else returns the hash value, and as a side effect,
    the square is entered into the hash table }

   var
    first, found: boolean;
    h, acc, i: integer;

   begin
    h:= 0;
    for i:= 1 to 4 do
     begin
      acc:= 10 * ord(sq[i]) + ord(sq[i+4]);
      h:= (10*h + acc) mod hash_max_plus
     end;
    h:= (h + ord(sq[9])) mod hash_max_plus;

    found:= false;
    repeat
     if hash_table[h,1] = 'a'
      then
       begin
        found:= true;
        first:= true;
        hash_table[h]:= sq
       end
     else if hash_table[h] = sq
      then
       begin
        found:= true;
        first:= false
       end
     else h:= (h + 63) mod hash_max_plus ;
    until found;

    if first
     then hash:= h
     else hash:= -1
   end { hash };

  function makenode (father: node; i: integer): node;
   var
    switch, space: integer;
    h: integer;
    sq: square;
    n: node;

   begin
    with father^ do
     begin
      space:= hole;
      sq:= hash_table[index]
     end;
    switch:= moves[space,i+1];
    if i > moves[space,1]
     then makenode:= nil
     else
      begin
       sq[space]:= sq[switch];
       sq[switch]:= ' ';
       h:= hash(sq);
       if h >= 0
        then
         begin
          new(n);
          with n^ do
           begin
            index:= h;
            hole:= switch;
            score:= evaluate(sq) + inc;
            parent:= father;
            next:= nil
           end;
          makenode:= n
         end
        else makenode:= nil;
       end
    end { makenode };

 begin { computer }
  gotoxy (1,20);
  write ('Give me a moment while I solve ');
  gotoxy (1,21);
  write ('this puzzle ... ');
  clreol;
  new (head);
  with head^ do
   begin
    index:= hash(original);
    hole:= 1;
    while original[hole] <> ' ' do hole:= hole + 1;
    score:= evaluate (original);
    parent:= nil;
    new (next);
    with next^ do
     begin
      score:= maxint;
      next:= nil
     end
   end;

  finished:= original = goal;
  inc:= 0;
  while not finished do
   begin
    n:= head;
    head:= head^.next;
    inc:= inc + 1;
    i:= 0;
    while (i < 4) and not finished do
     begin
      if inc > 500 then goto 999;
      i:= i + 1;
      son:= makenode(n,i);
      if son <> nil
       then
        begin
         insert (head, son);
         finished:= hash_table[son^.index] = goal
        end
       end;
     end;

999:
  if not finished
   then
    begin
     gotoxy (1,20);
     write ('Sorry to have wasted your time, ');
     gotoxy(1,21);
     write ('but that puzzle seems unsolvable');
     complay:= false
    end
   else
    begin
     son^.next:= nil;
     head:= son;
     while son^.parent <> nil do
      begin
       son:= son^.parent;
       son^.next:= head;
       head:= son
      end;

   compcount:= 0;
   print_square (original);
   while head <> nil do
    with head^ do
     begin
      head:= next;
      print_square(hash_table[index]);
      compcount:= compcount + 1;
      delay (50);
     end;

   gotoxy (1,22);
   write ('The computer finished in ');
   write (compcount:1, ' moves');
   clreol;
  end
 end { computer };

{***********************************************}

begin { main program }
 clrscr;
 video_mode:= get_mode;
 if video_mode <> 7 then set_mode (0);
 gotoxy(10,3);
 highvideo;
 write ('WELCOME TO THE 8 PUZZLE');
 normvideo;
 gotoxy (18,5);
 write ('Version ', version:1);
 initialise;
 print_square (original);

 gotoxy(1,20);
 write ('Do you want to try <y/n>? ');
 ch:= chr(inkey);
 if (ch = 'y') or (ch = 'Y')
  then
   begin
    humplay:= true;
    humcount:= 0;
    human
   end
  else humplay:= false;

 if humplay
  then
   begin
    gotoxy (1,17);
    write ('Your moves - ', humcount)
   end;

 gotoxy (1,19); clreol;
 gotoxy (1,22); clreol;
 gotoxy (1,24); clreol;
 gotoxy (1,20);
 write ('Do you want the computer  ');
 gotoxy (2,21);
 write ('to solve the puzzle <y/n>? ');
 ch:= chr(inkey);
 if (ch = 'y') or (ch = 'Y')
  then
   begin
    print_square (original);
    complay:= true;
    computer
   end
  else complay:= false;

 if complay
  then
   begin
    gotoxy (18,17);
    write ('My moves - ', compcount)
   end;

 gotoxy(1,23);
 if humplay and complay
  then if humcount < compcount
   then write ('You beat the computer!')
   else if humcount = compcount
    then write ('We came out equal that time')
    else write ('Better luck next time');
 clreol;
 gotoxy(1,24);
 write ('Press any key to finish ... ');
 compcount:= inkey;
 if video_mode <> 7 then set_mode (video_mode);
end.